home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swags_z.zip / STRINGS.SWG / 0100_Soundex Searching in Strings.pas < prev    next >
Pascal/Delphi Source File  |  1995-03-03  |  4KB  |  154 lines
  1. {
  2. [marcus is looking for an algorithm, which handles finding strings like
  3. german names, which sometimes are written with "umlauts" and sometimes
  4. not]
  5.  
  6. the solution for your problem is the soundex-algo.:
  7.  
  8. if, for example you have to index a database on strings, you normally
  9. would get an alphanumeric sequence by asciicode. instead the soundex will
  10. sort your records on a more phonetic way:
  11. }
  12.  
  13. (* procedure : soundex.pro
  14.    purpose   : search for similar sounding strings
  15.    compiler  : => tp 4.0
  16.    date      : 14.07.91
  17.  *)
  18.  
  19.  
  20. Type
  21.    Lstring = String[255];
  22. Var
  23.    CK_Name1,CK_Name2 : Lstring;
  24.  
  25.  
  26. {
  27. convert str to uppercase, careful, doesn't work with umlauts
  28. this function from swag does:
  29. Function UpCaseStr(St : string) : String;
  30. var
  31.   regs : registers;
  32. begin
  33.   Regs.DS := Seg(st[1]);
  34.   Regs.DX := Ofs(st[1]);
  35.   Regs.CX := Length(st);
  36.   Regs.AX := $6521;
  37.   MsDos(Regs);
  38.   UpCaseStr := St;
  39. end;
  40. }
  41.  
  42.  
  43. Procedure To_upper (Var str : Lstring);
  44. Var
  45.    I : Integer;
  46.  
  47. Begin
  48.    For I := 1 to Length (str) do
  49.       str [I] := upcase (str[I]);
  50.  
  51. End  {  To_Upper  };
  52.  
  53. { remove all occurances of double letters like wie oo,tt,ee, etc. }
  54.  
  55. Procedure eliminate_doubles (Var str : lstring);
  56. Var
  57.    I,J : Integer;
  58. Begin
  59.    For I := 1 to Length (str) do
  60.       Begin
  61.       If str [I] = str [I + 1] then
  62.          Begin
  63.          For J := I + 1 to Length (str)-1 do
  64.             str [J] := str [J + 1];
  65.          End
  66.       End
  67. End  {  eliminate_doubles  };
  68.  
  69. { Code 'Code' for soundex comparison }
  70.  
  71. Procedure Sound_Ex (var Code : Lstring);
  72. Var
  73.    I : Integer;
  74.    Sndex : Lstring;
  75.  
  76. Begin
  77.    Sndex := '';
  78.    Sndex := Sndex + Code [1];
  79.    For I := 2 to Length (Code) do
  80.       Begin
  81.       Case Code [I] of
  82.          'B','F','P','V'                 : Sndex := Sndex +  '1';
  83.          'C','G','J','K','Q','S','S','Z' : Sndex := Sndex +  '2';
  84.          'D','T'                         : Sndex := Sndex +  '3';
  85.          'L'                             : Sndex := Sndex +  '4';
  86.          'M','N'                         : Sndex := Sndex +  '5';
  87.          'R'                             : Sndex := Sndex +  '6';
  88.       End { case };
  89.       End { For };
  90.    If Length (Sndex) > 4 then Sndex := Copy (Sndex,1,4);
  91.    If Length (Sndex) < 4 then
  92.       For I := Length (Sndex) to 3 do Sndex := Sndex + '0';
  93.    Code := Sndex;
  94.  
  95. End  {  Sound_Ex  };
  96.  
  97. {**************************************************
  98.  * returns TRUE, if Name1 in Soundexcode          *
  99.  * ressembles to Name2, returns falsch, if not    *
  100.  **************************************************}
  101.  
  102. Function Sounds_Like (Name1,Name2 : Lstring) : Boolean;
  103. Var
  104.    Tnam1,Tnam2 : Lstring;
  105.  
  106. Begin
  107.    Tnam1 := Name1;
  108.    Tnam2 := Name2;
  109.    To_Upper (Tnam1);
  110.    To_Upper (Tnam2);
  111.    eliminate_doubles (Tnam1);
  112.    eliminate_doubles (Tnam2);
  113.    Sound_Ex (Tnam1);
  114.    Sound_Ex (Tnam2);
  115. Writeln;
  116. Writeln ('> ',Tnam1,' <> ',tnam2,' <');
  117.    If Tnam1 = Tnam2 then
  118.       Sounds_Like := TRUE
  119.    Else
  120.       Sounds_Like := FALSE;
  121.  
  122. End  {  Sounds_Like  };
  123.  
  124.  
  125.  
  126. {
  127. *******************
  128. *    DEMO         *
  129. *******************
  130. }
  131.  
  132.  
  133. Begin
  134.    Write ('1. Name please: ');Readln (CK_Name1);
  135.    Write ('2. Name please: ');Readln (CK_Name2);
  136.    Writeln;Writeln;
  137.    Writeln (CK_Name1,' and ',CK_Name2);
  138.    If Sounds_Like (CK_Name1,CK_Name2) Then
  139.       Writeln (' sound ALIKE !')
  140.    Else
  141.       Writeln (' do not sound alike at all !');
  142.  
  143. End.                          
  144.  
  145. {
  146. the used chars are languagedependant and should be used according to the
  147. distribution of their occurances in the used language. you have to trick
  148. around a bit with them, until you'll get the best result. those above
  149. should work fine for the english language (which again is spoken in this
  150. echo ;-) ).
  151. }
  152.  
  153.  
  154.